;;;DEBUGGING FUNCTION 
;;;	PRINTS LAST S-EXPRESSION EVALUATED AND WAITS FOR CHARACTER 
;;;	INPUT.  COMMANDS ARE:
;;;
;;;	D - MOVE DOWN THE STACK. (BACKWARDS IN TIME - I.E. NEXT TO 
;;;		LAST EXPRESSION EVALUATED) 
;;;	U - MOVE UP THE STACK. 
;;;	T - JUMP BACK TO THE TOP OF THE STACK. 
;;;
;;;	B - BREAK IN THE ENVIRONMENT OF THE CURRENT EXPRESSION BEING 
;;;		EXAMINED. THIS IS USEFULL FOR LOOKING AT VALUES OF 
;;;		VARIABLES IN THIS ENVIRONMENT. TYPE $P TO CONTINUE. 
;;;	P - PRINT THE CURRENT S-EXPRESSION IN ITS ENTIRETY.
;;;	Q - QUIT THE FUNCTION DEBUG. 
;;;	R - FORCE THE CURRENT EXPRESSION TO RETURN. 
;;;		ASKS FOR VERIFIATION AND THEN 
;;;		ASKS FOR A VALUE (WHICH IS EVALUATED) TO BE RETURNED.
;;;	C - LIKE "R" BUT RE-EVALUATES THE CURRENT EXPRESSION.
;;;	# - IF A POSITIVE NUMBER ,N, PRECEEDS A COMMAND, THEN THAT
;;;		COMMAND WILL BE EXECUTED "N" TIMES.
;;;	? - PRINT INFO ON COMMANDS 

(DECLARE (GENPREFIX DEBUG)) 

(DECLARE (*LEXPR DEBUG VERIFY)) 

(DEFUN DEBUG #ARGS 
       (PROG (POINTER BACK-POINTERS CHAR TOP-POINTER NUMBER) 
	     (COND ((= #ARGS 1.)
		    (AND (*RSET (NOUUO (ARG 1.))) (SSTATUS UUOLINKS))
		    (RETURN (ARG 1.)))
		   ((SETQ POINTER (EVALFRAME NIL))
		    (OR POINTER (RETURN 'TRY-SETTING-*RSET)))
		   ((RETURN 'STACK-SCREWED-UP--SORRY)))
	FIND-START
	     (COND ((EQ (CAADDR POINTER) 'DEBUG)
		    (SETQ POINTER (CADR POINTER) TOP-POINTER POINTER))
		   ((SETQ POINTER (EVALFRAME (CADR POINTER)))
		    (GO FIND-START)))
	     (SETQ NUMBER 0.)
	PRINT((LAMBDA (PRINLEVEL PRINLENGTH) 
		      (PRINT (CADDR (EVALFRAME POINTER))))
	      3.
	      4.)
	     (TERPRI)
	READLOOP
	     (SETQ CHAR (READCH2))
	NOREAD
	     (COND
	      ((NUMBERP CHAR)
	       (SETQ NUMBER (+ (* NUMBER 10.) CHAR))
	       (GO READLOOP))
	      ((EQ CHAR 'D)
	       (COND ((EVALFRAME (CADR (EVALFRAME POINTER)))
		      (SETQ BACK-POINTERS (CONS POINTER
						BACK-POINTERS) 
			    POINTER (CADR (EVALFRAME POINTER))))
		     ((> NUMBER 1.) (SETQ NUMBER 0.))
		     ((PRINT '(YOU ARE AT THE BOTTOM OF THE STACK)))))
	      ((EQ CHAR 'U)
	       (COND
		(BACK-POINTERS
		 (SETQ POINTER (CAR BACK-POINTERS) 
		       BACK-POINTERS (CDR BACK-POINTERS)))
		((> NUMBER 1.) (SETQ NUMBER 0.))
		((PRINT '(YOU ARE AT THE TOP OF THE STACK)))))
	      ((EQ CHAR 'B)
	       (EVAL '(BREAK DEBUG T)
		     (CADDDR (EVALFRAME POINTER))))
	      ((EQ CHAR 'Q) (RETURN 'END-DEBUG))
	      ((EQ CHAR 'T)
	       (SETQ POINTER TOP-POINTER BACK-POINTERS NIL))
	      ((EQ CHAR 'C)
	       (AND (VERIFY 'RE-EVALUATE
			    'CURRENT
			    'EXPRESSION?)
		    (FRETURN (CADR (EVALFRAME POINTER))
			     (EVAL (CADDR (EVALFRAME POINTER))))))
	      ((EQ CHAR 'R)
	       (COND ((VERIFY 'FORCE
			      'RETURN
			      'FROM
			      'CURRENT
			      'EXPRESSION?)
		      (TERPRI)
		      (PRINC '>>>WHAT/ SHOULD/ THIS/ S-EXPRESSION/ RETURN?/ / )
		      (FRETURN (CADR (EVALFRAME POINTER))
			       (EVAL (READ))))))
	      ((MEMQ CHAR '(/  /
/
)) (GO READLOOP))
	      ((EQ CHAR 'P)
	       (PRINT (CADDR (EVALFRAME POINTER)))
	       (GO READLOOP))
	      ((EQ CHAR 'S)
	       (SPRINTER (CADDR (EVALFRAME POINTER)))
	       (GO READLOOP))
	      ((EQ CHAR '?)
	       (PRINT '(OPTIONS ARE: D U B T R C Q P OR ?))
	       (GO READLOOP))
	      ((PRINC '/ ???/ ) (GO READLOOP)))
	     (AND (> NUMBER 1.) (SETQ NUMBER (1- NUMBER)))
	     (AND (> NUMBER 0.) (GO NOREAD))
	     (GO PRINT))) 

;;;READS A CHARACTER AND RETURNS THAT CHARACTER AS EITHER A 
;;;	NUMBER OR A SYMBOL.

(DEFUN READCH2 NIL 
       (PROG (X) 
	     (SETQ X (TYI))
	     (RETURN (COND ((LESSP 47. X 58.) (- X 48.))
			   ((ASCII X)))))) 

;;;TO GET AROUND JONL'S WEIRD SPELLING

(SETQ BACKTRACE 'BAKTRACE) 

(DEFUN BT NIL 
       (PROG (#SPACES BTLIST ) 
	     (SETQ 
		   #SPACES 0. 
		   BTLIST (BAKLIST))
	     (DO NIL
		 ((OR (NULL BTLIST) (EQ (CAAR BTLIST) 'BT)))
		 (SETQ BTLIST (CDR BTLIST)))
(AND (= #ARGS 1)
(DO ((I (ARG 1)(1- (ARG 1)))(LIST BTLIST (CDR LIST)))
    ((NULL LIST) T)
(AND (= I 0.)(RPLACD LIST NIL)(RETURN T))))

	     (TERPRI)
	     (MAPC 
	      '(LAMBDA (X) (DO I #SPACES (1- I) (= I 0.) (TYO 32.))
			   (SETQ #SPACES (COND ((< #SPACES 30.)
						(1+ #SPACES))
					       (T 0.)))
			   (PRINC (CAR X))
			   (TERPRI))
	      (NREVERSE (CDR BTLIST)))
	     (RETURN '*))) 

(DEFUN VERIFY #ARGS 
       (DECLARE (FIXNUM I))
       (TERPRI)
       (DO ((I 1. (1+ I))) ((> I #ARGS) T) (PRINC (ARG I)) (TYO 32.))
       (TERPRI)
       (PRINC 'TYPE/ YES/ OR/ NO:)
       (EQ (READ) 'YES)) 
))))))